home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / FASTSAVE.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  5.4 KB  |  152 lines
  1. ; FASTSAVE.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Create a .FSL file from a code block            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: LB            Date: 1992            *
  16. ;* Revision history:                            *
  17. ;* - 14 Aug 92:    Tested (lb))                        *
  18. ;* - 13 Sep 92: Added 16-bit integer support (lb)            *
  19. ;*                                    *
  20. ;*                    ``In nomine omnipotentii dei''    *
  21. ;************************************************************************
  22.  
  23. (define (fast-save l . port)
  24.   (define max-int 65536)
  25.   (define max-pos 32767)
  26.   (define max-neg -32768)
  27.   (define max-byte 256)
  28.   (define max-nibble 16)
  29.   (define (put . l)
  30.     (when (pair? l)
  31.           (if (null? port)
  32.           (princ (car l))
  33.           (princ (car l) (car port)))
  34.           (apply put (cdr l))))
  35.   (define (putln)
  36.     (put #\RETURN #\NEWLINE))
  37.  
  38.   (define (hex h)
  39.     (list->string (list (integer->char (+ h (if (>= h 10)
  40.                                                 (- (char->integer #\A) 10)
  41.                                                 (char->integer #\0)))))))
  42.   (define (byte b)
  43.     (if (< b 0)
  44.         (byte (+ b max-byte))
  45.         (string-append (hex (quotient b max-nibble))
  46.                        (hex (remainder b max-nibble)))))
  47.   (define (word w)
  48.     (if (< w 0)
  49.         (word (+ w max-int))
  50.         (string-append (byte (quotient w max-byte))
  51.                        (byte (remainder w max-byte)))))
  52.   
  53.   (define (process-constants l)
  54.     (define (process-vec vec i)
  55.       (if (< i (vector-length vec))
  56.           (begin (process (vector-ref vec i))
  57.                  (process-vec vec (1+ i)))))
  58.     (define (process-big big)
  59.       (define (big->list big)
  60.         (if (< big max-int)
  61.             (list big)
  62.             (cons (remainder big max-int) (big->list (quotient big max-int)))))
  63.       (define (print-big l)
  64.         (if (not (null? l))
  65.             (begin (put (word (car l)))
  66.                    (print-big (cdr l)))))
  67.       (let ((l (big->list (abs big))))
  68.         (put (byte (length l)) (byte (if (positive? big) 0 1)))
  69.         (print-big l)))
  70.     
  71.     (define (process c)
  72.       (cond ((string? c) (put #\s (word (string-length c)) c))
  73.             ((null? c) (put #\n))
  74.             ((pair? c) (put #\l) (process (car c)) (process (cdr c)))
  75.             ((vector? c) (put #\v (word (vector-length c))) (process-vec c 0))
  76.             ((char? c) (put #\c (byte (char->integer c))))
  77.             ((symbol? c) (put #\x (byte (string-length (symbol->string c))) c))
  78.             ((integer? c) (if (and (<= c max-pos) (>= c max-neg))
  79.                               (put #\i (word c))
  80.                               (begin (put #\b) (process-big c))))
  81.             ((number? c) (put #\f (word (%reify c 0)) (word (%reify c 1))
  82.                                   (word (%reify c 2)) (word (%reify c 3))))
  83.             (else (error "Unknown object" c))))
  84.     (if (not (null? l))
  85.         (begin (process (car l))
  86.                (putln)
  87.                (process-constants (cdr l)))))
  88.  
  89.   (define (process-codebytes c)
  90.     (put (integer->char (car c)))
  91.     (if (not (null? (cdr c)))
  92.         (process-codebytes (cdr c))))
  93.  
  94.   (if (not (eq? (car l) 'pcs-code-block))
  95.       (error "Use: (fast-save '(pcs-code-block ...))"))
  96.   (let ((const# (cadr l))
  97.         (code# (caddr l))
  98.         (const (cadddr l))
  99.         (code (car (cddddr l))))
  100.     (if (or (<> const# (length const))
  101.             (<> code# (length code)))
  102.         (error "Code sizes do not match."))
  103.     (put "h" (word const#) " " (word code#))
  104.     (putln)
  105.     (process-constants const)
  106.     (put #\t)
  107.     (process-codebytes code)
  108.     (putln)
  109.     (put #\z)
  110.     (putln)))
  111.  
  112. (define (fast-save-file from . to)
  113.   (define (codeblock? object)
  114.     (and (member (car object) '(execute %execute))
  115.          (eq? (caadr object) 'quote)
  116.      (eq? (car (cadadr object)) 'pcs-code-block)))
  117.   (define (doport reader inport outport)
  118.     (let ((object (reader inport)))
  119.       (if (not (eof-object? object))
  120.           (begin (if (codeblock? object)
  121.                      (fast-save (cadadr object) outport)
  122.                      (let ((form (compile object)))
  123.                        (fast-save form outport)
  124.                (%execute form)))
  125.                  (doport reader inport outport)))))
  126.   (define (dostring file outport)
  127.     (let ((inport (open-input-file file)))
  128.       (doport (if (string-ci=? (cadddr (filename-split file)) ".sw")
  129.           read-sw
  130.           read)
  131.           inport
  132.           outport)
  133.       (close-input-port inport)))
  134.   (define (dolist list outport)
  135.     (when (pair? list)
  136.           (dostring (car list) outport)
  137.           (dolist (cdr list) outport)))
  138.   (define (name-fsl name)
  139.     (apply string-append
  140.        (reverse (cons ".fsl" (cdr (reverse (filename-split name)))))))
  141.   (let ((port (open-binary-output-file
  142.                 (if (pair? to)
  143.                     (car to)
  144.                     (name-fsl (if (pair? from) (car from) from))))))
  145.     (princ "#!fast-load 4.0 " port)
  146.     (princ (if (pair? from) from (list from)) port)
  147.     (princ #\RETURN port)
  148.     (princ #\NEWLINE port)
  149.     ((if (pair? from) dolist dostring) from port)
  150.     (close-output-port port))
  151.   'OK)
  152.